home *** CD-ROM | disk | FTP | other *** search
/ MacTech 1 to 12 / MacTech-vol-1-12.toast / Source / MacTech® Magazine / Volume 07 - 1991 / 07.09 Sep 91 / Jorg September Code / CtlWind next >
Encoding:
Text File  |  1991-06-22  |  4.2 KB  |  175 lines  |  [TEXT/McSk]
  1. \ ctlWind - Window subclass adding controls etc.
  2.  
  3. \ May  91 mrh    Extensively revised adding standard vert & horiz scroll bar
  4. \        and zoom box support.
  5.  
  6. decimal
  7.  
  8. need    ctl
  9. need    vscroll
  10.  
  11.     objPtr    theSB    class_is vscroll
  12.     0    value    MPOINT
  13.  
  14.  
  15. : CTLEXEC    \ ( part# ctlHndl -- )  Executes action for control.
  16.      get-ctl-obj  exec: **  ;
  17.  
  18. \ CtlProc is the procedure to be executed when a control is being tracked.
  19.  
  20. :proc  CTLPROC    \  ( ctlHndl int:part -- )
  21.     word0 swap  ctlExec  ;proc
  22.  
  23.  
  24. : CTLHIT?  { wind \ part ^ctl action1 action2 -- bool }
  25.         \ Look for control click
  26.     where: fEvent  g->l  -> mpoint            \ save mouse loc
  27.     word0  mpoint  wind  theCtl  call FindControl
  28.     word0  -> part  theCtl @  -> ^ctl        \ ctl handle
  29.     part
  30.     CASE[ inThumb ],  [ inCheckBox ],  [ inButton ]=>
  31.                         \ Only exec after mouseUp
  32.         0 ->  action1        \ 0 since gets passed to TrackControl
  33.         ['] ctlExec  -> action2
  34.     DEFAULT=>
  35.         drop  ['] ctlproc -> action1  ['] 2drop -> action2
  36.     ]CASE
  37.     ^ctl
  38.     IF
  39.         word0  ^ctl  mpoint  action1  call TrackControl  word0
  40.         ^ctl  action2 execute  true
  41.     ELSE
  42.         false
  43.     THEN  ;
  44.  
  45.  
  46. \ Note: if your Window is a subclass of CtlWind and has scroll bars,
  47. \ it should set the scroll bars to 255 hiliting on a deactivate event.
  48. \ This can be done via the Disable: method in VScroll.  But if the scroll
  49. \ bars are default ones set up via setVscroll:  and setHscroll:, this
  50. \ will all be looked after for you.
  51.  
  52.  
  53. :class    CTLWIND    super{ window }
  54.  
  55.     ptr    ^VSCROLL
  56.     ptr    ^HSCROLL
  57.  
  58.     bool    ZOOMFLG
  59.     
  60. private
  61.  
  62. :m VSCROLL?:    get: ^vscroll  nilP  <>  ;m
  63.  
  64. :m HSCROLL?:    get: ^hscroll  nilP  <>  ;m
  65.  
  66. :m ?SBtoEdge:
  67.     vscroll?: self  IF  get: ^vscroll  edge: vscroll  THEN
  68.     hscroll?: self  IF  get: ^hscroll  edge: hscroll  THEN  ;m
  69.  
  70. public
  71.  
  72. :m SETZOOM:    \ ( b -- )  Passed-in boolean indicates if this window will be
  73.         \  zoomable.
  74.     put: zoomFlg  ;m
  75.  
  76. :m SETVSCROLL:  { vscr lo hi \ left top rt bot -- }
  77.  
  78.   \ Sets up a vertical scroll bar in the usual position.  vscr is the addr of
  79.   \ a vscroll object, and lo and hi gives the range.  All the housekeeping for
  80.   \ the scroll bar is looked after automatically.
  81.  
  82.     vscr  put: ^vscroll   vscr -> theSB
  83.     getVrect: self
  84.     -> bot  -> rt  -> top  -> left
  85.     left  top  bot 1+  ^base  new: theSB
  86.     lo hi putRange: theSB  ;m
  87.  
  88. :m SETHSCROLL:  { hscr lo hi \ left top rt bot -- }
  89.  
  90.  \ Sets up a horizontal scroll bar in the usual position.
  91.  
  92.     hscr  put: ^hscroll   hscr  ['] theSB  !  ( strictly, classes don't match )
  93.     getHrect: self
  94.     -> bot  -> rt  -> top  -> left
  95.     left  top  rt 1+  ^base  new: theSB
  96.     lo hi putRange: theSB
  97.     setView: self  ;m
  98.  
  99. :m NEW: { bndsRect tAddr tLen procID vis goAway \ s255 -- }
  100.  
  101.   \ Defines a new window on the heap with the specified features.
  102.   \ Not resource based.  Only change in this subclass is to use
  103.   \ zoomFlg to modify the procID.
  104.  
  105.     get: alive  ?EXIT            \ Out if already alive
  106.     ?disable_actW: self
  107.     tAddr tLen  str255  -> s255
  108.     0  ^base  bndsrect  s255  vis Tbool
  109.     get: zoomFlg  8 and  procID + makeint
  110.     inFront  goAway Tbool  0
  111.     call NewWindow  drop
  112.     initNewWindow: self  ;m
  113.  
  114. :m GROW:    grow: super  ?SBtoEdge: self  ;m
  115.  
  116. :m ZOOM:    zoom: super  set: super  ?SBtoEdge: self  ;m
  117.  
  118. :m ENABLE:
  119.     vscroll?: self  IF  get: ^vscroll  enable: vscroll  THEN
  120.     hscroll?: self  IF  get: ^hscroll  enable: hscroll  THEN
  121.     enable: super  ;m
  122.  
  123. :m DISABLE:
  124.     vscroll?: self  IF  get: ^vscroll  disable: vscroll  THEN
  125.     hscroll?: self  IF  get: ^hscroll  disable: hscroll  THEN
  126.     disable: super  ;m
  127.  
  128.  
  129. :m DRAW:    \ Draws the window with controls
  130.     draw: super  ^base  call DrawControls  ;m
  131.  
  132. :m CLOSE:    \ Disposes of window's controls and closes the window
  133.     ^base  call KillControls  close: super  ;m
  134.  
  135. :m CONTENT:    \ Handles a content click
  136.     active: self
  137.     IF
  138.         ^base  ctlHit?
  139.         NIF  exec: content  THEN
  140.     ELSE
  141.         select: self
  142.     THEN  ;m
  143.  
  144. :m TEST:
  145.     100 100 300 200 put: tempRect
  146.     screenbits true setGrow: self
  147.     tempRect  " Test"  docWind  true true  new: self
  148.     true  setZoom: self  ;m
  149.  
  150. ;class
  151.  
  152. endload
  153.  
  154. \ TESTING:
  155.  
  156. ctlWind    WW
  157. hscroll    VV1
  158. vscroll VV2
  159.  
  160.    screenbits    true  setGrow: ww
  161.         true  setZoom: ww
  162.  
  163. : GO
  164.     CFAS{  lnup lndn null null null  }  actions: vv1
  165.     CFAS{  lnup lndn null null null  }  actions: vv2
  166.     test: ww  vv1 0 20 sethscroll: ww  vv2 0 10 setvscroll: ww  ;
  167.  
  168. : RR        \ Test getting things from a resource file
  169.     " WindTest.rsrc" openresfile
  170.     128 db getNew: ww
  171.     128 ww getNew: vv1  ;
  172.  
  173.  
  174. : ZZ    set: fwind  close: vv1  close: vv2  close: ww  ;
  175.